home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_lf1.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  13.8 KB  |  611 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_lf1.c */
  5.  
  6. #include "clos.h"
  7.  
  8.  
  9. /* funzioni principali ********************************/
  10. /* CAR     , CDR    , CONS     , QUOTE  , EVAL , COND */
  11. /* SETF    , SET    , APPEND   , LIST   , LAST , ELT  */
  12. /* REVERSE , LENGHT , FUNCTION , PLIST                */
  13. /* DEFVAR  , DEFUN  , DEFMACRO , BACKQUOTE , NAME2STR */
  14. /******************************************************/
  15.  
  16. /* nota:************************/
  17. /* SETQ  è tradotta in SETF    */
  18. /* FIRST è tradotta in CAR     */
  19. /* REST  è tradotta in CDR     */
  20. /*******************************/
  21.  
  22. void aux_set_setf();
  23.  
  24. void lf_car LF_PARAMS
  25. {
  26.  if(IS_CONS(nin)){
  27.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  28.     nin=calc_pointer(nout);
  29.     if(IS_CONS(nin)){
  30.     nout->node=nin;
  31.     nout->type=P_CONSLEFT;
  32.     return;
  33.     }
  34.     error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  35.  }
  36.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  37. }
  38.  
  39. void lf_cdr LF_PARAMS
  40. {
  41.  if(IS_CONS(nin)){
  42.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  43.     nin=calc_pointer(nout);
  44.     if(IS_CONS(nin)){
  45.     nout->node=nin;
  46.     nout->type=P_CONSRIGHT;
  47.     return;
  48.     }
  49.     error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  50.  }
  51.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  52. }
  53.  
  54. void lf_cons LF_PARAMS
  55. {
  56.  node n;
  57.  node e=nin;
  58.  
  59.  TYPE(n=node_make())|=NT_IS_CONS;
  60.  CONSLEFT(n)=CONSRIGHT(n)=NIL;
  61.  
  62.  if(IS_CONS(nin)){
  63.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  64.     CONSLEFT(n)=calc_pointer(nout);
  65.     if(IS_CONS(nin=CONSRIGHT(nin))){
  66.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  67.     CONSRIGHT(n)=calc_pointer(nout);
  68.     nout->node=n;
  69.     nout->type=P_ALLNODE;
  70.     return;
  71.     }
  72.     error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&e);
  73.  }
  74.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&e);
  75. }
  76.  
  77. void lf_quote LF_PARAMS
  78. {
  79.  if(IS_CONS(nin)){
  80.    nout->node=CONSLEFT(nin);
  81.    nout->type=P_ALLNODE;
  82.    return;
  83.  }
  84.  error(E_FEWARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&nin);
  85. }
  86.  
  87. void lf_eval LF_PARAMS
  88. {
  89.  if(IS_CONS(nin)){
  90.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  91.     eval(calc_pointer(nout),nout,genv,lenv,fl);
  92.     return;
  93.  }
  94.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  95. }
  96.  
  97. void lf_cond LF_PARAMS
  98. {
  99.  node n;
  100.  /* syntax (COND ( test oksx*)*) */
  101.  /* nin=( ( test oksx*)* ) */
  102.  
  103.  while(IS_CONS(nin)){
  104.    n=CONSLEFT(nin); /* n= (test oksx*) */
  105.    if(IS_CONS(n)){
  106.      eval(CONSLEFT(n),nout,genv,lenv,EVAL_NORM);
  107.      if(calc_pointer(nout)!=NIL){ /* nout=EVAL(test) */
  108.     n=CONSRIGHT(n); /* n= (oksx*) */
  109.     if(!IS_CONS(n)){
  110.       nout->node=NIL;
  111.       nout->type=P_ALLNODE;
  112.       return;
  113.     }
  114.     while(IS_CONS(CONSRIGHT(n))){
  115.        eval(CONSLEFT(n),nout,genv,lenv,EVAL_NORM);
  116.        n=CONSRIGHT(n);
  117.     }
  118.     eval(CONSLEFT(n),nout,genv,lenv,fl);
  119.     return;
  120.      }
  121.      nin=CONSRIGHT(nin); /* nin=next test */
  122.      continue;
  123.    }
  124.    /* else   n=sx */
  125.    eval(n,nout,genv,lenv,fl);
  126.    if(calc_pointer(nout)!=NIL)return;
  127.    nin=CONSRIGHT(nin);
  128.    continue;
  129.  }
  130.  nout->type=P_ALLNODE;
  131.  nout->node=NIL;
  132. }
  133.  
  134. void aux_set_setf (nin,nout,genv,lenv,fl,dbleval)
  135. node nin;
  136. node_p *nout;
  137. node genv;
  138. node lenv;
  139. unsigned fl;
  140. int dbleval;
  141. {
  142.  /* sintassi (SETF { n  v }+) */
  143.  /* assegna al legame e(n) il valore e(v) */
  144.  
  145.  node_p tmpp;
  146.  node    t=nin;
  147.  
  148.  if(nin==NIL)
  149.    error(E_FEWARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&NIL);
  150.  
  151.  while(nin!=NIL){
  152.    if(IS_CONS(nin)){
  153.      /* il flag EVAL_SETF costringe eval a non causare l'errore */
  154.      /* UNBOUND ATOM ... se non c'e' nulla attaccato al nome */
  155.      /* valutato, ed eval ritornerà in ogni caso il legame che  */
  156.      /* verrà poi collegato */
  157.      if(dbleval){
  158.        eval(CONSLEFT(nin),nout,genv,lenv,fl);
  159.        eval(calc_pointer(nout),&tmpp,genv,lenv,EVAL_SETF);
  160.      }else{
  161.        eval(CONSLEFT(nin),&tmpp,genv,lenv,EVAL_SETF);
  162.      }
  163.      nin=CONSRIGHT(nin);
  164.      if(IS_CONS(nin)){
  165.        eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  166.        switch(tmpp.type){
  167.      case P_VALUE:
  168.        VALUE(tmpp.node)=calc_pointer(nout);
  169.        break;
  170.      case P_FUNC:
  171.        FUNCTION(tmpp.node)=calc_pointer(nout);
  172.        break;
  173.      case P_PLIST:
  174.        PLIST(tmpp.node)=calc_pointer(nout);
  175.        break;
  176.      case P_CONSLEFT:
  177.        CONSLEFT(tmpp.node)=calc_pointer(nout);
  178.        break;
  179.      case P_CONSRIGHT:
  180.         CONSRIGHT(tmpp.node)=calc_pointer(nout);
  181.         break;
  182.      case P_UNBOUNDVALUE:
  183.         /* eval(col flag EVAL_SETF) ritorna P_UNBOUNDxxxx */
  184.         /* riferito al legame del nodo che non aveva valore */
  185.         /* al posto di causare un errore */
  186.         VALUE(tmpp.node)=calc_pointer(nout);
  187.         TYPE(tmpp.node)|=NT_HAS_VALUE;
  188.         break;
  189.       case P_UNBOUNDFUNC:
  190.         FUNCTION(tmpp.node)=calc_pointer(nout);
  191.         TYPE(tmpp.node)|=NT_HAS_FUNCTION;
  192.         break;
  193.       case P_UNBOUNDPLIST:
  194.         PLIST(tmpp.node)=calc_pointer(nout);
  195.         TYPE(tmpp.node)|=NT_HAS_PLIST;
  196.         break;
  197.       case P_ALLNODE:
  198.         /* non si puo' assegnare nulla ad un legame */
  199.         /* imprecisato come P_ALLNODE */
  200.         /* ad.es se si fa (setf 12 34) */
  201.         error(E_BADARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&tmpp.node);
  202.       default:
  203.         error(E_BADSETF,ERR_TCRIT|ERR_MINTERNAL|ERR_PVOID,NULL);
  204.     }
  205.       }
  206.       else{
  207.     error(nin==NIL?E_FEWARGS:E_BADLIST,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&t);
  208.       }
  209.     }
  210.     else{
  211.       error(nin==NIL?E_FEWARGS:E_BADLIST,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&t);
  212.     }
  213.     nin=CONSRIGHT(nin);
  214.  }
  215. }
  216.  
  217.  
  218. void lf_set LF_PARAMS
  219. {
  220.  /* sintassi (set (nome valore)* ) */
  221.  /* NB: ''nome,, viene valutato 2 volte */
  222.  aux_set_setf(nin,nout,genv,lenv,fl,1);
  223. }
  224.  
  225. void lf_setf LF_PARAMS
  226. {
  227.  /* sintassi (setf (nome valore)* ) */
  228.  /* NB: ''nome,, viene valutato 1 volta */
  229.  aux_set_setf(nin,nout,genv,lenv,fl,0);
  230. }
  231.  
  232. void lf_list LF_PARAMS
  233. {
  234.  nout->node=eval_list(nin,genv,lenv);
  235.  nout->type=P_ALLNODE;
  236. }
  237.  
  238. void lf_nconc LF_PARAMS
  239. {
  240.  node list=eval_list(nin,genv,lenv);
  241.  node prevcons=NIL;
  242.  node elm;
  243.  
  244.  nout->node=NIL;
  245.  nout->type=P_ALLNODE;
  246.  while(IS_CONS(list)){
  247.    elm=CONSLEFT(list);
  248.    if(nout->node==NIL)nout->node=elm;
  249.    if(elm!=NIL){
  250.      if(!IS_CONS(elm))error(E_BADARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&elm);
  251.      if(prevcons!=NIL)CONSRIGHT(prevcons)=elm;
  252.      do{
  253.        prevcons=elm;
  254.        elm=CONSRIGHT(elm);
  255.      }while(IS_CONS(elm));
  256.    }
  257.    list=CONSRIGHT(list);
  258.  }
  259. }
  260.  
  261. void lf_append LF_PARAMS
  262. {
  263.  node list=eval_list(nin,genv,lenv);
  264.  node prevcons=NIL;
  265.  node elm;
  266.  
  267.  nout->node=NIL;
  268.  nout->type=P_ALLNODE;
  269.  while(IS_CONS(list)){
  270.    elm=list_dup(CONSLEFT(list));
  271.    if(nout->node==NIL)nout->node=elm;
  272.    if(elm!=NIL){
  273.      if(!IS_CONS(elm))error(E_BADARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&elm);
  274.      if(prevcons!=NIL)CONSRIGHT(prevcons)=elm;
  275.      do{
  276.        prevcons=elm;
  277.        elm=CONSRIGHT(elm);
  278.      }while(IS_CONS(elm));
  279.    }
  280.    list=CONSRIGHT(list);
  281.  }
  282. }
  283.  
  284. void lf_last LF_PARAMS
  285. {
  286.  node var;
  287.  if(IS_CONS(nin)){
  288.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  289.    var=calc_pointer(nout);
  290.    if(IS_CONS(var)){
  291.      while(IS_CONS(CONSRIGHT(var)))
  292.        var=CONSRIGHT(var);
  293.      nout->node=var;
  294.      nout->type=P_CONSLEFT;
  295.      return;
  296.    }
  297.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&var);
  298.  }
  299.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  300. }
  301.  
  302. void lf_elt LF_PARAMS
  303. {
  304.  node list;
  305.  node n=nin;
  306.  n_int counter;
  307.  
  308.  
  309.  if(IS_CONS(nin)){
  310.   eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  311.   list=calc_pointer(nout);
  312.   if(!IS_CONS(list))error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&list);
  313.   nin=CONSRIGHT(nin);
  314.   if(IS_CONS(nin)){
  315.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  316.     nin=calc_pointer(nout);
  317.     if(GET_NTYPE(nin)==NT_IS_VALUE && GET_VTYPE(nin)==NT_INTEGER){
  318.       if((counter=INTEGER(nin))>0){
  319.     while(--counter){
  320.       if(IS_CONS(list))
  321.         list=CONSRIGHT(list);
  322.       else
  323.         error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNINT,&INTEGER(nin));
  324.     }
  325.     if(IS_CONS(list)){
  326.       nout->type=P_CONSLEFT;
  327.       nout->node=list;
  328.       return;
  329.     }
  330.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNINT,&INTEGER(nin));
  331.       }
  332.     }
  333.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  334.   }
  335.  }
  336.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  337. }
  338.  
  339.  
  340.  
  341. void lf_reverse LF_PARAMS
  342. {
  343.  int i;
  344.  char *b=buf1;
  345.  if(IS_CONS(nin)){
  346.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  347.      nin=calc_pointer(nout);
  348.      if(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_STRING){
  349.        string_get(STRING(nin),b);
  350.        i=strlen(b);
  351.        buf2[i]=0;
  352.        while(i--){
  353.      buf2[i]=*b++;
  354.        }
  355.        TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_STRING;
  356.        STRING(nout->node)=string_put(buf2,nout->node);
  357.        nout->type=P_ALLNODE;
  358.        return;
  359.      }
  360.      nout->type=P_ALLNODE;
  361.      nout->node=NIL;
  362.      while(IS_CONS(nin)){
  363.      TYPE(genv=node_make())|=NT_IS_CONS;
  364.      CONSLEFT(genv)=CONSLEFT(nin);
  365.      CONSRIGHT(genv)=nout->node;
  366.      nout->node=genv;
  367.      nin=CONSRIGHT(nin);
  368.      }
  369.      return;
  370.  }
  371.  error(E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  372. }
  373.  
  374.  
  375. void lf_lenght LF_PARAMS
  376. {
  377.  if(IS_CONS(nin)){
  378.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  379.      nin=calc_pointer(nout);
  380.      nout->type=P_ALLNODE;
  381.      if(IS_CONS(nin) || nin==NIL){
  382.     TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_INTEGER;
  383.     INTEGER(nout->node)=(n_int)listlen_func(nin);
  384.     return;
  385.      }
  386.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  387.  }
  388.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  389. }
  390.  
  391.  
  392.  
  393.  
  394. void  lf_function LF_PARAMS
  395. {
  396.  /* sintassi (function nome) oppure #'nome */
  397.  /* ritorna un puntatore al legame funzionale del nodo-argomento */
  398.  /* se il nome non è un simbolo allora lo si valuta*/
  399.  if(IS_CONS(nin)){
  400.    nout->node=nin=CONSLEFT(nin);
  401.    if(!IS_NAME(nin)){
  402.      eval(nin,nout,genv,lenv,EVAL_SETF);
  403.      if(!IS_NAME(nout->node))
  404.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nout->node);
  405.    }
  406.    if( HAS_FUNCTION(nout->node) ){
  407.      nout->type=P_FUNC;
  408.      return;
  409.    }
  410.    if(fl==EVAL_SETF){
  411.      nout->type=P_UNBOUNDFUNC;
  412.      return;
  413.    }
  414.    error(E_UNBOUNDFUNC,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  415.  }
  416.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  417. }
  418.  
  419.  
  420. void  lf_plist LF_PARAMS
  421. {
  422.  /* ritorna un puntatore al legame plist del nodo-argomento */
  423.  if(IS_CONS(nin)){
  424.    if(IS_NAME(CONSLEFT(nin))){
  425.      nout->node=CONSLEFT(nin);
  426.    }else{
  427.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  428.      nout->node=calc_pointer(nout);
  429.      if(!IS_NAME(nout->node))
  430.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nout->node);
  431.    }
  432.    if( HAS_PLIST(nout->node) ){
  433.      nout->type=P_PLIST;
  434.      return;
  435.    }
  436.    if(fl==EVAL_SETF){
  437.      nout->type=P_UNBOUNDPLIST;
  438.      return;
  439.    }
  440.    nout->node=node_alloc(UNBOUND_ID);
  441.    nout->type=P_ALLNODE;
  442.    return;
  443.  }
  444.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  445. }
  446.  
  447. void lf_defvar LF_PARAMS
  448. {
  449.  node name;
  450.  
  451.  /* sintassi (defvar {nome valore}+) */
  452.  
  453.  if(IS_CONS(nin)){
  454.    while(IS_CONS(nin)){
  455.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_SETF);
  456.      if(IS_NAME(nout->node)){
  457.        name=nout->node;
  458.        nin=CONSRIGHT(nin);
  459.        if(IS_CONS(nin)){
  460.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  461.      nin=CONSRIGHT(nin);
  462.        }else{
  463.      nout->type=P_ALLNODE;
  464.      nout->node=NIL;
  465.        }
  466.        if(HAS_BIND(name)){
  467.      nout->node=NIL;
  468.      nout->type=P_ALLNODE;
  469.        }else{
  470.      TYPE(name)|=NT_HAS_BIND;
  471.      TYPE(name)&=(~NT_HAS_VALUE);
  472.      VALUE(name)=calc_pointer(nout);
  473.        }
  474.      }else{
  475.        error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nout->node);
  476.      }
  477.    }
  478.    return;
  479.  }
  480.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  481. }
  482.  
  483.  
  484.  
  485. void lf_defun LF_PARAMS
  486. {
  487.  node fn;
  488.  
  489.  /* sintassi (defun nome <lambda-form>) */
  490.  /* se nome non è un simbolo allora lo si valuta */
  491.  
  492.  if(IS_CONS(nin)){
  493.    fn=CONSLEFT(nin);
  494.    if(!IS_NAME(fn)){
  495.      eval(fn,nout,genv,lenv,EVAL_SETF);
  496.      if(!IS_NAME(nout->node))
  497.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nout->node);
  498.      fn=nout->node;
  499.    }
  500.    lf_lambda(CONSRIGHT(nin),nout,genv,lenv,EVAL_NORM);
  501.    TYPE(fn)|=NT_HAS_FUNCTION;
  502.    FUNCTION(fn)=FUNCTION(nout->node);
  503.    return;
  504.  }
  505.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  506. }
  507.  
  508. void lf_defmacro LF_PARAMS
  509. {
  510.  node fn;
  511.  
  512.  /* sintassi (defmacro nome <lambda-form>) */
  513.  /* se nome non è un simbolo allora lo si valuta */
  514.  
  515.  if(IS_CONS(nin)){
  516.    fn=CONSLEFT(nin);
  517.    if(!IS_NAME(fn)){
  518.      eval(fn,nout,genv,lenv,EVAL_SETF);
  519.      if(!IS_NAME(nout->node))
  520.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nout->node);
  521.      fn=nout->node;
  522.    }
  523.    lf_lambda(CONSRIGHT(nin),nout,genv,lenv,EVAL_NORM);
  524.    TYPE(fn)|=NT_HAS_FUNCTION;
  525.    FUNCTION(fn)=FUNCTION(nout->node);
  526.    TYPE(FUNCTION(fn))=NT_IS_VALUE+NT_MACRO;
  527.    return;
  528.  }
  529.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  530. }
  531.  
  532. node Coma,Genv,Lenv;
  533. node_p Nout;
  534.  
  535. void backquote_scan_element();
  536.  
  537.  
  538. void lf_backquote LF_PARAMS
  539. {
  540.  /* sintassi (backquote ( s-espressioni) ) */
  541.  
  542.  node last=NIL;
  543.  
  544.  Coma=node_alloc("COMA");
  545.  Genv=genv;
  546.  Lenv=lenv;
  547.  if(IS_CONS(nin)){
  548.    if(IS_CONS(nin=CONSLEFT(nin))){
  549.      while(IS_CONS(nin)){
  550.      if(last==NIL){
  551.          last=nout->node=node_make();
  552.      }else{
  553.          CONSRIGHT(last)=node_make();
  554.          last=CONSRIGHT(last);
  555.      }
  556.      TYPE(last)|=NT_IS_CONS;
  557.      CONSLEFT(last)=CONSRIGHT(last)=NIL;
  558.      backquote_scan_element(CONSLEFT(nin),&CONSLEFT(last));
  559.      nin=CONSRIGHT(nin);
  560.      }
  561.      nout->type=P_ALLNODE;
  562.      return;
  563.    }
  564.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  565.  }
  566.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  567. }
  568.  
  569. void backquote_scan_element(el,where)
  570. node el;
  571. node  *where;
  572. {
  573.  if(IS_CONS(el)){
  574.     if(CONSLEFT(el)==Coma){
  575.     if(IS_CONS(el))
  576.         el=CONSRIGHT(el);
  577.     eval(CONSLEFT(el),&Nout,Genv,Lenv,EVAL_NORM);
  578.     *where=calc_pointer(&Nout);
  579.     return;
  580.     }
  581.     TYPE(*where=node_make())|=NT_IS_CONS;
  582.     CONSLEFT(*where)=NIL;
  583.     CONSRIGHT(*where)=NIL;
  584.     backquote_scan_element(CONSLEFT(el),&CONSLEFT(*where));
  585.     backquote_scan_element(CONSRIGHT(el),&CONSRIGHT(*where));
  586.     return;
  587.  }
  588.  *where=el;
  589. }
  590.  
  591.  
  592.  
  593.  
  594. void lf_name2str LF_PARAMS
  595. {
  596.  
  597.  if(IS_CONS(nin)){
  598.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  599.    nin=calc_pointer(nout);
  600.    if(IS_NAME(nin)){
  601.      nout->node=node_make();
  602.      STRING(nout->node)=string_put(string_get(NAME(nin),buf1),nout->node);
  603.      TYPE(nout->node)|=NT_IS_VALUE+NT_STRING;
  604.      nout->type=P_ALLNODE;
  605.      return;
  606.    }
  607.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  608.  }
  609.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  610. }
  611.